home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Taifun
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip
/
Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf
/
PCQ
/
Source
/
Expression.p
< prev
next >
Wrap
Text File
|
1989-03-31
|
20KB
|
727 lines
external;
{
Expression.p (of PCQ Pascal)
Copyright (c) 1989 Patrick Quaid
This module only has two parts. The first is expression(),
which handles all run-time expressions. The other one is
conexpr(), which handles all constant expressions.
}
const
{$I "pasconst.i"}
type
{$I "pastype.i"}
var
{$I "pasvar.i"}
function typecheck(l, r : integer) : boolean;
forward;
procedure nextsymbol;
forward;
procedure gch;
forward;
procedure error(s : string);
forward;
procedure callfunc(f : integer);
forward;
procedure stdfunc(f : integer);
forward;
function match(s : integer): boolean;
forward;
function findid(s : string) : integer;
forward;
procedure printlabel(l : integer);
forward;
function getlabel() : integer;
forward;
function selector(f : integer) : integer;
forward;
procedure mismatch;
forward;
procedure noleftparent;
forward;
procedure norightparent;
forward;
procedure neednumber;
forward;
procedure needrightparent;
forward;
procedure needleftparent;
forward;
function suffix(s : integer) : char;
forward;
function numbertype(l : integer) : boolean;
forward;
function basetype(b : integer): integer;
forward;
procedure writehex(h : integer);
forward;
procedure promotetype(var f : integer; o, r : integer);
forward;
function expression() : integer;
forward;
function readlit(firstchar : char) : integer;
{
This routine reads a literal array of char into the literal
array. Read factor() to figure out why this is passed
firstchar....
}
var
length : integer;
begin
length := 1;
litq[litptr] := firstchar;
litptr := litptr + 1;
while (currentchar <> chr(39)) and (currentchar <> chr(10)) do begin
litq[litptr] := currentchar;
gch;
if currentchar = chr(10) then
error("missing closing apostrophe");
length := length + 1;
litptr := litptr + 1;
end;
gch;
nextsymbol;
readlit := length;
end;
function simpletype(testtype : integer) : boolean;
{
If a variable passes this test, it is held in a register
during processing. If not, the address of the variable is held in
the register. This is the main reason why type conversions don't
work across all types of the same size.
}
begin
simpletype := (idents[testtype].size <= 4) and
(idents[testtype].size <> 3) and
(idents[testtype].offset <> vrecord) and
(idents[testtype].offset <> varray);
end;
function idfactor(factindex : integer) : integer;
{
idfactor() is another nightmare function. It does whatever
is necessary when the compiler runs across an identifer in an
expression, which almost always means loading a value into d0.
}
var
facttype : integer;
selecttype : integer;
originaltype : integer;
begin
if factindex <> 0 then begin
facttype := idents[factindex].vtype;
if idents[factindex].object = func then begin
{ call a user-defined function }
callfunc(factindex);
idfactor := facttype;
end else if idents[factindex].object = stanfunc then begin
{ 'call' a standard function, which is actually handled
in-line. }
stdfunc(factindex);
idfactor := idents[factindex].vtype;
end else if idents[factindex].object = obtype then begin
{ this implements the type conversion thing. }
needleftparent;
selecttype := expression();
needrightparent;
idfactor := factindex;
end else if idents[factindex].object = constant then begin
{ load a constant or enumeration. Expand this when
real numbers and string constants are included. }
writeln(output, "\tmove.l\t#", idents[factindex].offset, ',d0');
idfactor := idents[factindex].vtype;
end else begin
{ it's probably a variable }
selecttype := selector(factindex);
if selecttype <> 0 then begin
{ there was some sort of selection required }
facttype := selecttype;
originaltype := idents[factindex].vtype;
if idents[factindex].object = global then begin
if (idents[originaltype].offset = vpointer) or
(idents[originaltype].offset = vfile) then
writeln(output, "\tmove.l\td0,a0")
else begin
writeln(output, "\tmove.l\t#_",
idents[factindex].name, ',a0');
writeln(output, "\tadd.l\td0,a0");
end
end else if idents[factindex].object = refarg then begin
if (idents[originaltype].offset = vpointer) or
(idents[originaltype].offset = vfile) then
writeln(output, "\tmove.l\td0,a0")
else begin
writeln(output, "\tmove.l\t", idents[factindex].offset,
'(a5),a0');
writeln(output, "\tadd.l\td0,a0");
end
end else begin
if (idents[originaltype].offset = vpointer) or
(idents[originaltype].offset = vfile) then
writeln(output, "\tmove.l\td0,a0")
else begin
writeln(output, "\tlea\t", idents[factindex].offset,
'(a5),a0');
writeln(output, "\tadd.l\td0,a0");
end
end;
if simpletype(facttype) then
writeln(output, "\tmove.", suffix(idents[facttype].size),
"\t(a0),d0");
else
writeln(output, "\tmove.l\ta0,d0");
end else begin
{ this is a simple variable }
if idents[factindex].object = global then begin
if not simpletype(facttype) then begin
writeln(output, "\tmove.l\t#_",
idents[factindex].name, ',d0');
end else begin
writeln(output,"\tmove.",suffix(idents[facttype].size),
"\t_", idents[factindex].name, ',d0');
end
end else if (idents[factindex].object = local) or
(idents[factindex].object = valarg) then begin
if not simpletype(facttype) then begin
writeln(output, "\tlea\t", idents[factindex].offset,
'(a5),a0');
writeln(output, "\tmove.l\ta0,d0");
end else begin
writeln(output,"\tmove.",suffix(idents[facttype].size),
chr(9), idents[factindex].offset, '(a5),d0');
end;
end else if idents[factindex].object = refarg then begin
if not simpletype(facttype) then begin
writeln(output, "\tmove.l\t", idents[factindex].offset,
'(a5),d0');
end else begin
writeln(output, "\tmove.l\t", idents[factindex].offset,
'(a5),a0');
writeln(output, "\tmove.",suffix(idents[facttype].size),
"\t(a0),d0");
end;
end else begin
error("expecting a variable or function");
facttype := badtype;
end;
end;
idfactor := facttype;
end;
error("expecting an expression");
idfactor := badtype;
end else begin
error("Unknown identifier");
idfactor := badtype;
end;
end;
function factor() : integer;
{
This is the lowest level of the expression parsing
business. It's pretty standard stuff. All these expression
routines return the index of the type they're working on.
}
var
facttype : integer;
factindex : integer;
length : integer;
firstchar : char;
begin
if currsym = ident1 then begin
factindex := findid(symtext);
nextsymbol;
facttype := idfactor(factindex);
end else if currsym = numeral1 then begin
if abs(symloc) > 32767 then begin
facttype := inttype;
write(output, "\tmove.l\t#");
writehex(symloc);
writeln(output, ',d0');
end else begin
{ assumes short integers for literals...}
writeln(output, "\tmove.w\t#", symloc, ',d0');
facttype := shorttype;
end;
nextsymbol;
{ end else if currsym = realnumeral1 then begin
write(output, "\tmove.l\t#");
writehex(integer(realnum));
writeln(output, ",d0");
facttype := realtype;
nextsymbol; }
end else if currsym = apostrophe1 then begin
firstchar := currentchar;
gch;
if currentchar <> chr(39) then begin
write(output, "\tmove.l\t#");
printlabel(litlab);
writeln(output, '+', litptr - 1, ',d0');
length := readlit(firstchar);
idents[literaltype].upper := length;
idents[literaltype].size := length;
facttype := literaltype;
end else begin
gch;
nextsymbol;
writeln(output, "\tmove.b\t#", ord(firstchar), ',d0');
facttype := chartype;
end;
end else if match(not1) then begin
facttype := factor();
if not typecheck(facttype, booltype) then begin
error("NOT applies only to Booleans");
facttype := badtype;
end else
writeln(output, "\tnot.b\td0");
end else if match(leftparent1) then begin
facttype := expression();
needrightparent;
end else if currsym = quote1 then begin
{ Read a string. This should go to a separate procedure }
write(output, "\tmove.l\t#");
printlabel(litlab);
writeln(output, '+', litptr - 1, ',d0');
while (currentchar <> '"') and (currentchar <> chr(10)) do begin
if currentchar = '\' then begin
gch;
if currentchar = 't' then
litq[litptr] := chr(9)
else if currentchar = 'n' then
litq[litptr] := chr(10)
else
litq[litptr] := currentchar;
end else
litq[litptr] := currentchar;
gch;
if currentchar = chr(10) then
error("missing close quote");
litptr := litptr + 1;
end;
gch;
nextsymbol;
litq[litptr] := chr(0);
litptr := litptr + 1;
facttype := stringtype;
end else begin
error("bizarre expression");
facttype := badtype;
end;
factor := facttype;
end;
function operate(lefttype, righttype, operator : integer) : integer;
{
This routine handles the actual code generation for the
various operations. This handles all the math stuff, even though
it's called by different routines. In the next version this bit
will properly handle the multiplication and division of 32 bit
values.
}
begin
if not typecheck(lefttype, righttype) then begin
mismatch;
lefttype := badtype;
end else begin
writeln(output, "\tmove.l\t(sp)+,d1");
if (operator = and1) or (operator = or1) then begin
if not typecheck(lefttype, booltype) then
error("Need Boolean expression for AND and OR");
end else begin
if numbertype(lefttype) then begin
promotetype(lefttype, righttype, 1);
promotetype(righttype, lefttype, 0);
end else
neednumber;
end;
{ The following arithmetic operations will undergo a major
change when two more things are added. They are, not
surprisingly, real math and full 32 bit multiplication
and division. Each of the following cases will have to
be fleshed out a bit to decide what kind of math routines
to use for a particular operation. }
if operator = asterisk1 then begin
if lefttype = bytetype then begin
promotetype(lefttype, shorttype, 1);
promotetype(righttype, shorttype, 0);
end;
writeln(output, "\tmuls\td1,d0");
lefttype := inttype;
end else if operator = div1 then begin
if lefttype <> inttype then begin
promotetype(lefttype, inttype, 1);
promotetype(righttype, shorttype, 0);
end;
writeln(output, "\tdivs\td0,d1");
writeln(output, "\tmove.l\td1,d0");
lefttype := shorttype;
end else if operator = mod1 then begin
if lefttype <> inttype then begin
promotetype(lefttype, inttype, 1);
promotetype(righttype, shorttype, 0);
end;
writeln(output, "\tdivs\td0,d1");
writeln(output, "\tmove.l\td1,d0");
writeln(output, "\tswap\td0");
lefttype := shorttype;
end else if operator = and1 then begin
writeln(output, "\tand.b\td1,d0")
end else if operator = plus1 then begin
writeln(output, "\tadd.", suffix(idents[lefttype].size),
"\td1,d0");
end else if operator = minus1 then begin
writeln(output, "\tsub.", suffix(idents[lefttype].size),
"\td1,d0");
writeln(output, "\tneg.", suffix(idents[lefttype].size),
"\td0");
end else if operator = or1 then
writeln(output, "\tor.b\td1,d0")
end;
operate := lefttype;
end;
function term() : integer;
{
Again, pretty standard stuff. This handles the level of
precedence that includes *, div, mod, and and.
}
var
lefttype : integer;
righttype : integer;
stay : boolean;
begin
lefttype := factor();
stay := true;
while stay do begin
if match(asterisk1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := factor();
lefttype := operate(lefttype, righttype, asterisk1);
end else if match(div1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := factor();
lefttype := operate(lefttype, righttype, div1);
end else if match(mod1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := factor();
lefttype := operate(lefttype, righttype, mod1);
end else if match(and1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := factor();
lefttype := operate(lefttype, righttype, and1);
end else
stay := false;
end;
term := lefttype;
end;
function simple() : integer;
{
This is similar to term(), except it handles plus, minus,
or, and unary minus.
}
var
lefttype : integer;
righttype : integer;
stay : boolean;
begin
if match(minus1) then begin
lefttype := term();
if not typecheck(lefttype, inttype) then begin
error("need numeric type for unary minus");
lefttype := badtype;
end else
writeln(output, "\tneg.", suffix(idents[lefttype].size),"\td0");
end else
lefttype := term();
stay := true;
while stay do begin
if match(plus1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := term();
lefttype := operate(lefttype, righttype, plus1);
end else if match(minus1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := term();
lefttype := operate(lefttype, righttype, minus1);
end else if match(or1) then begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := term();
lefttype := operate(lefttype, righttype, or1);
end else
stay := false;
end;
simple := lefttype;
end;
function exprrelop(lefttype, operation : integer) : integer;
{
This handles the code for the various relative comparisons
(like <, >, <=, etc.)
}
var
righttype : integer;
begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := simple();
if not typecheck(lefttype, righttype) then begin
mismatch;
lefttype := badtype;
end else if idents[lefttype].offset <> vordinal then begin
error("only simple types allowed in inequalities");
lefttype := badtype;
end else begin
writeln(output, "\tmove.l\t(sp)+,d1");
if numbertype(lefttype) then begin
promotetype(lefttype, righttype, 1);
promotetype(righttype, lefttype, 0);
end;
writeln(output, "\tcmp.", suffix(idents[lefttype].size), "\td0,d1");
if operation = less1 then
writeln(output, "\tslt\td0")
else if operation = greater1 then
writeln(output, "\tsgt\td0")
else if operation = notless1 then
writeln(output, "\tsge\td0")
else if operation = notgreater1 then
writeln(output, "\tsle\td0");
lefttype := booltype;
end;
exprrelop := lefttype;
end;
function expreqop(lefttype, operation : integer) : integer;
{
This generated code for comparisons of equality. The main
difference between this and the previous routine is that Pascal
allows the comparison of complex types, so this routine has to
handle that.
}
var
righttype : integer;
lab : integer;
totalsize : integer;
begin
writeln(output, "\tmove.l\td0,-(sp)");
righttype := simple();
if not typecheck(lefttype, righttype) then begin
mismatch;
lefttype := badtype;
writeln(output, "\tmove.l\t(sp)+,d0");
end else begin
totalsize := idents[lefttype].size;
if not simpletype(lefttype) then begin
{ If we got here, this must be a complex type. Therefore
compare the two objects byte by byte. }
writeln(output, "\tmove.l\td0,a0");
writeln(output, "\tmove.l\t(sp)+,a1");
writeln(output, "\tmove.b\t#-1,d0");
writeln(output, "\tmove.l\t#", totalsize, ",d1");
lab := getlabel();
printlabel(lab);
writeln(output, "\tmove.b\t(a0)+,d2");
writeln(output, "\tcmp.b\t(a1)+,d2");
writeln(output, "\tseq\td2");
writeln(output, "\tand.b\td2,d0");
write(output, "\tdbra\td1,");
printlabel(lab);
writeln(output);
writeln(output, "\ttst.b\td0");
if operation = notequal1 then
writeln(output, "\tseq\td0");
end else begin
writeln(output, "\tmove.l\t(sp)+,d1");
if numbertype(lefttype) then begin
promotetype(lefttype, righttype, 1);
promotetype(righttype, lefttype, 0);
end;
writeln(output, "\tcmp.", suffix(idents[lefttype].size), "\td0,d1");
if operation = equal1 then
writeln(output, "\tseq\td0")
else if operation = notequal1 then
writeln(output, "\tsne\td0");
end;
lefttype := booltype;
end;
expreqop := lefttype;
end;
function expression() : integer;
{
This is the main part of expression(). If there weren't
any errors, the result of the expression will be in d0.
}
var
lefttype : integer;
begin
lefttype := simple();
if match(equal1) then
lefttype := expreqop(lefttype, equal1)
else if match(notequal1) then
lefttype := expreqop(lefttype, notequal1)
else if match(less1) then
lefttype := exprrelop(lefttype, less1)
else if match(greater1) then
lefttype := exprrelop(lefttype, greater1)
else if match(notless1) then
lefttype := exprrelop(lefttype, notless1)
else if match(notgreater1) then
lefttype := exprrelop(lefttype, notgreater1);
expression := lefttype;
end;
function conexpr(var c : integer) : integer;
forward;
function conprimary(var contype : integer) : integer;
{
These routines are very similar to the other expression
routines, but are much simpler. They return the running value of
the expression. The type is returned in the reference parameter.
This routine should handle type conversions and standard functions.
}
var
result : integer;
idindex : integer;
begin
if match(leftparent1) then begin
result := conexpr(contype);
needrightparent;
conprimary := result;
end else if currsym = numeral1 then begin
result := symloc;
nextsymbol;
contype := inttype;
conprimary := result;
end else if match(minus1) then begin
conprimary := -conprimary(contype);
end else if currsym = apostrophe1 then begin
contype := chartype;
result := ord(currentchar);
gch;
if currentchar <> chr(39) then begin
error("Only single character constants allowed.");
while (currentchar <> ';') and (currentchar <> chr(39)) and
(currentchar <> chr(10)) and (currentchar <> chr(0)) do
gch();
end;
gch;
nextsymbol;
conprimary := result;
end else if currsym = ident1 then begin
idindex := findid(symtext);
if idents[idindex].object = constant then begin
nextsymbol;
contype := idents[idindex].vtype;
conprimary := idents[idindex].offset;
end else begin
error("expecting a constant");
contype := inttype;
conprimary := 1;
end;
end else begin
error("unknown constant");
contype := inttype;
conprimary := 1;
end;
end;
function confactor(var contype : integer) : integer;
{
This handles the second level of precedence for constant
expressions.
}
var
result, rightresult : integer;
righttype : integer;
begin
result := conprimary(contype);
while (currsym = asterisk1) or (currsym = div1) do begin
if match(asterisk1) then begin
rightresult := conprimary(righttype);
if typecheck(contype, righttype) then
result := result * rightresult
else
mismatch;
end else if match(div1) then begin
rightresult := conprimary(righttype);
if typecheck(contype, righttype) then begin
if rightresult = 0 then begin
error("Division by zero");
rightresult := 1;
end;
result := result div rightresult;
end else
mismatch;
end;
end;
confactor := result;
end;
function conexpr(var contype : integer) : integer;
{
This handles the other level of constant expressions, and
is also the outermost level.
}
var
result : integer;
rightresult : integer;
righttype : integer;
begin
result := confactor(contype);
while (currsym = minus1) or (currsym = plus1) do begin
if match(minus1) then begin
rightresult := confactor(righttype);
if typecheck(contype, righttype) then
result := result - rightresult
else
mismatch;
end else if match(plus1) then begin
rightresult := confactor(righttype);
if typecheck(contype, righttype) then
result := result + rightresult
else
mismatch;
end;
end;
conexpr := result;
end;